home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / cgai386.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  51KB  |  1,291 lines
  1. {
  2.     $Id: cgai386.pas,v 1.4.2.1 1998/04/09 23:29:23 peter Exp $
  3.     Copyright (c) 1993-98 by Florian Klaempfl
  4.  
  5.     This unit generates i386 (or better) assembler from the parse tree
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************}
  22.  
  23. unit cgai386;
  24.  
  25.   interface
  26.  
  27.     uses
  28.        objects,cobjects,systems,globals,tree,symtable,types,strings,
  29.        pass_1,hcodegen,aasm,i386,tgeni386,files,verbose
  30. {$ifdef GDB}
  31.        ,gdb
  32. {$endif GDB}
  33.        ;
  34.  
  35.     procedure emitl(op : tasmop;var l : plabel);
  36.     procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
  37.     procedure emitcall(const routine:string;add_to_externals : boolean);
  38.      procedure emitloadord2reg(location:Tlocation;orddef:Porddef;
  39.                               destreg:Tregister;delloc:boolean);
  40.     { produces jumps to true respectively false labels using boolean expressions }
  41.     procedure maketojumpbool(p : ptree);
  42.     procedure emitoverflowcheck(p:ptree);
  43.     procedure push_int(l : longint);
  44.     function maybe_push(needed : byte;p : ptree) : boolean;
  45.     procedure restore(p : ptree);
  46.     procedure emit_push_mem(const ref : treference);
  47.     procedure emitpushreferenceaddr(const ref : treference);
  48.      procedure swaptree(p:Ptree);
  49.     procedure copystring(const dref,sref : treference;len : byte);
  50.     procedure loadstring(p:ptree);
  51.     procedure concatcopy(source,dest : treference;size : longint;delsource : boolean);
  52.     { see implementation }
  53.     procedure maybe_loadesi;
  54.  
  55.     procedure floatload(t : tfloattype;const ref : treference);
  56.     procedure floatstore(t : tfloattype;const ref : treference);
  57.     procedure floatloadops(t : tfloattype;var op : tasmop;var s : topsize);
  58.     procedure floatstoreops(t : tfloattype;var op : tasmop;var s : topsize);
  59.  
  60.     procedure firstcomplex(p : ptree);
  61.     procedure secondfuncret(var p : ptree);
  62.  
  63.     { initialize respectively terminates the code generator }
  64.     { for a new module or procedure                         }
  65.     procedure codegen_doneprocedure;
  66.     procedure codegen_donemodule;
  67.     procedure codegen_newmodule;
  68.     procedure codegen_newprocedure;
  69.  
  70.     { generate entry code for a procedure.}
  71.     procedure genentrycode(const proc_names:Tstringcontainer;make_global:boolean;
  72.                            stackframe:longint;
  73.                            var parasize:longint;var nostackframe:boolean);
  74.     { generate the exit code for a procedure. }
  75.     procedure genexitcode(parasize:longint;nostackframe:boolean);
  76.  
  77.   implementation
  78.  
  79.     {
  80.     procedure genconstadd(size : topsize;l : longint;const str : string);
  81.  
  82.       begin
  83.          if l=0 then
  84.          else if l=1 then
  85.            exprasmlist^.concat(new(pai386,op_A_INC,size,str)
  86.          else if l=-1 then
  87.            exprasmlist^.concat(new(pai386,op_A_INC,size,str)
  88.          else
  89.            exprasmlist^.concat(new(pai386,op_ADD,size,'$'+tostr(l)+','+str);
  90.       end;
  91.     }
  92.  
  93.     procedure copystring(const dref,sref : treference;len : byte);
  94.  
  95.       var
  96.          pushed : tpushed;
  97.  
  98.       begin
  99.          emitpushreferenceaddr(dref);
  100.          emitpushreferenceaddr(sref);
  101.          push_int(len);
  102.          emitcall('STRCOPY',true);
  103.          maybe_loadesi;
  104.       end;
  105.  
  106.     procedure loadstring(p:ptree);
  107.       begin
  108.         case p^.right^.resulttype^.deftype of
  109.          stringdef : begin
  110.                        if (p^.right^.treetype=stringconstn) and
  111.                           (p^.right^.values^='') then
  112.                         exprasmlist^.concat(new(pai386,op_const_ref(
  113.                            A_MOV,S_B,0,newreference(p^.left^.location.reference))))
  114.                        else
  115.                         copystring(p^.left^.location.reference,p^.right^.location.reference,
  116.                            min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len));
  117.                      end;
  118.             orddef : begin
  119.                        if p^.right^.treetype=ordconstn then
  120.                          exprasmlist^.concat(new(pai386,op_const_ref(
  121.                             A_MOV,S_W,p^.right^.value*256+1,newreference(p^.left^.location.reference))))
  122.                        else
  123.                          begin
  124.                             { not so elegant (goes better with extra register }
  125.                             if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  126.                               begin
  127.                                  exprasmlist^.concat(new(pai386,op_reg_reg(
  128.                                     A_MOV,S_L,reg8toreg32(p^.right^.location.register),R_EDI)));
  129.                                  ungetregister32(reg8toreg32(p^.right^.location.register));
  130.                               end
  131.                             else
  132.                               begin
  133.                                  exprasmlist^.concat(new(pai386,op_ref_reg(
  134.                                     A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI)));
  135.                                  del_reference(p^.right^.location.reference);
  136.                               end;
  137.                             exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,8,R_EDI)));
  138.                             exprasmlist^.concat(new(pai386,op_const_reg(A_OR,S_L,1,R_EDI)));
  139.                             exprasmlist^.concat(new(pai386,op_reg_ref(
  140.                                A_MOV,S_W,R_DI,newreference(p^.left^.location.reference))));
  141.                          end;
  142.                      end;
  143.         else
  144.          Message(sym_e_type_mismatch);
  145.         end;
  146.       end;
  147.  
  148.  
  149.     procedure restore(p : ptree);
  150.  
  151.       var
  152.          hregister :  tregister;
  153.  
  154.       begin
  155.          hregister:=getregister32;
  156.          exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,hregister)));
  157.          if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  158.           p^.location.register:=hregister
  159.          else
  160.            begin
  161.               reset_reference(p^.location.reference);
  162.               p^.location.reference.index:=hregister;
  163.               set_location(p^.left^.location,p^.location);
  164.            end;
  165.       end;
  166.  
  167.     function maybe_push(needed : byte;p : ptree) : boolean;
  168.  
  169.       var
  170.          pushed : boolean;
  171.          {hregister : tregister; }
  172.  
  173.       begin
  174.          if needed>usablereg32 then
  175.            begin
  176.               if (p^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  177.                 begin
  178.                    pushed:=true;
  179.                    exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.location.register)));
  180.                    ungetregister32(p^.location.register);
  181.                 end
  182.               else if (p^.location.loc in [LOC_MEM,LOC_REFERENCE]) and
  183.                       ((p^.location.reference.base<>R_NO) or
  184.                        (p^.location.reference.index<>R_NO)
  185.                       ) then
  186.                   begin
  187.                      del_reference(p^.location.reference);
  188.                      exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.location.reference),
  189.                        R_EDI)));
  190.                      exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI)));
  191.                      pushed:=true;
  192.                   end
  193.               else pushed:=false;
  194.            end
  195.          else pushed:=false;
  196.          maybe_push:=pushed;
  197.       end;
  198.  
  199.     procedure emitl(op : tasmop;var l : plabel);
  200.  
  201.       begin
  202.          if op=A_LABEL then
  203.            exprasmlist^.concat(new(pai_label,init(l)))
  204.          else
  205.            exprasmlist^.concat(new(pai_labeled,init(op,l)))
  206.       end;
  207.  
  208.     procedure em